home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / MENU_UTL / BMENU / BMENU.PAS next >
Pascal/Delphi Source File  |  1990-09-07  |  11KB  |  316 lines
  1. unit BMenu;     { John Haluska CIS 74000,1106 }    { Turbo Pascal 5.5 }
  2.  
  3. { Ver 1.0  8/15/90  Released to the public domain. }
  4.  
  5. { BMenu contains objects to generate a Lotus style bar menu where each menu
  6.   item can be selected by the cursor/enter keys or a specified character.
  7.   Menu items are stored as a linked list in the heap.  Typical use:
  8.  
  9.   1.  Declare a MMenuPtr variable:    M : MMenuPtr;
  10.       Declare a char variable to receive the menu select character:  Ch : char;
  11.  
  12.   2.  Initialize the menu to setup the linked list, define select characters
  13.       (1 for each menu item), and menu item background/text colors:
  14.  
  15.         New(M,Init('ABCD',Red*16+LightGray));
  16.  
  17.   3.  Initialize the screen column/row position and title for each menu item
  18.       in order of the select character:
  19.  
  20.         M^.Append(New(MItemPtr,Init(5,5, ' A Item ')));
  21.         M^.Append(New(MItemPtr,Init(15,5,' B Item ')));
  22.         M^.Append(New(MItemPtr,Init(25,5,' C Item ')));
  23.         M^.Append(New(MItemPtr,Init(35,5,' D Item ')));
  24.  
  25.   4.  Display the menu with the initial choice "A" hilited.  Then return the
  26.       Esc character if the Esc key is pressed or the select character if the
  27.       cursor/enter keys or a select character is pressed:
  28.  
  29.         Ch := M^.MenuPick('A');
  30.  
  31.   5.  Deallocate heap memory or deallocate heap memory and remove the menu
  32.       from the screen:
  33.  
  34.         Dispose(M,Done);     or      Dispose(M,EraseMenu);    }
  35.  
  36. interface
  37.  
  38. uses Crt,Objects;  { Objects unit from TP5.5 OOPDEMOS.ARC }
  39.  
  40. type
  41.  
  42. MItemPtr = ^MItem;
  43. MItem = object(Node)       { Node from the Object unit }
  44.   C : byte;                { Menu item screen start column location }
  45.   R : byte;                { Menu item screen row location }
  46.   PTitle : ^string;        { Menu item title }
  47.   constructor Init(Col,Row : word; Title : string);
  48.   destructor Done; virtual
  49. end;
  50.  
  51. MMenuPtr = ^MMenu;
  52. MMenu = object(List)       { List from the Object unit }
  53.   NormVid,RevVid : byte;
  54.   SelStr : ^string;
  55.   constructor Init(SelChStr : string; NormVideo: byte);
  56.   function MenuPick(InitCh : char) : char;
  57.   destructor Done; virtual;
  58.   destructor EraseMenu;
  59.   function Specific(N : word) : NodePtr;
  60.   function Cardinal : word
  61. end;
  62.  
  63. procedure ErrorTone;
  64. function  ReadValidChar(S : string) : char;
  65. procedure CursorOn(State : boolean);
  66.  
  67. implementation
  68.  
  69. {----------------------------------------------------------------------------}
  70. { ErrorTone generates a 120Hz tone for .1 second. }
  71.  
  72. procedure ErrorTone;
  73. begin
  74.   Sound(120);  Delay(100);  NoSound
  75. end;
  76. {----------------------------------------------------------------------------}
  77. { ReadValidChar reads and validates a keystroke against uppercase ASCII
  78.   characters, defined in string S, until a valid character is entered.
  79.   Lowercase letters (a-z) are returned as uppercase (A-Z).  Extended scan
  80.   codes < 128 are returned with 128 added to the scan code.  For example, F1
  81.   with a scan code 59 is returned as 187.  A character not in S is ignored
  82.   and the tone is sounded.  Example: The expression VK := ReadValidChar('ABC')
  83.   will return A, B, or C if the corresponding key is pressed or sound a tone
  84.   if any other key is pressed. }
  85.  
  86. function ReadValidChar(S : string) : char;
  87.  
  88. var
  89.   C,Cs  : char;
  90.   OK : boolean;
  91. begin
  92.   repeat
  93.     OK := false;
  94.     C := UpCase(ReadKey);
  95.     case C of
  96.       #1..#127 : if Pos(C,S) <> 0 then OK := true else ErrorTone;
  97.       #0 : begin
  98.              Cs := ReadKey;
  99.              if Ord(Cs) < 128 then
  100.                begin
  101.                  C := Chr(Ord(Cs) + 128);
  102.                  if Pos(C,S) <> 0 then OK := true else ErrorTone
  103.                end
  104.              else ErrorTone
  105.            end
  106.       else ErrorTone
  107.     end;
  108.   until OK;
  109.   ReadValidChar := C
  110. end;  {ReadValidChar}
  111. {----------------------------------------------------------------------------}
  112. { CursorOn turns off (False) or turns on (True) the screen display cursor.
  113.   Example:  CursorOn(False)  turns off (hides) the cursor.  }
  114.  
  115. procedure CursorOn(State : boolean);
  116.  
  117. begin
  118.   inline(
  119.   $B4/$03/               {    MOV     AH,3          ;Call BIOS Service 10h/3 -}
  120.   $B7/$00/               {    MOV     BH,0          ;  Get Cursor Position}
  121.   $CD/$10/               {    INT     $10           ;   & Size}
  122.   $8A/$96/>State/        {    MOV     DL,>State[BP] ;Save cursor on/off in DL}
  123.   $0A/$D2/               {    OR      DL,DL         ;Turn cursor off?}
  124.   $74/$06/               {    JZ      X1            ;Yes}
  125.   $81/$E1/$FF/$DF/       {    AND     CX,$DFFF      ;No, turn off bit 5 of CH}
  126.   $EB/$04/               {    JMP     SHORT X2  }
  127.   $81/$C9/$00/$20/       {X1: OR      CX,$2000      ;Yes, turn on bit 5 of CH}
  128.   $B4/$01/               {X2: MOV     AH,1          ;Call BIOS Service 10h/1 -}
  129.   $CD/$10)               {    INT     $10           ;  Set Cursor Size}
  130. end;  {CursorOn}
  131. {----------------------------------------------------------------------------}
  132. { Initialize menu item with screen location (Col, Row) and Title. }
  133.  
  134. constructor MItem.Init(Col,Row : word; Title : string);
  135. begin
  136.   GetMem(PTitle,Length(Title)+1);
  137.   C := Col;
  138.   R := Row;
  139.   PTitle^ := Title
  140. end;
  141. {----------------------------------------------------------------------------}
  142. { Remove item data from heap. }
  143.  
  144. destructor MItem.Done;
  145. begin
  146.   FreeMem(PTitle,Length(PTitle^) + 1)
  147. end;
  148. {----------------------------------------------------------------------------}
  149. { Specific sets and returns the address of the Nth list item.  Returns nil
  150.   if the list is empty or N is greater than the total items in the list.  }
  151.  
  152. function MMenu.Specific(N : word) : NodePtr;
  153. var
  154.   Np : NodePtr;
  155.   I  : word;
  156. begin
  157.   if N = 0 then
  158.     Specific := nil
  159.   else
  160.     begin
  161.       Np := First;           { 1st object in list }
  162.       I := 1;
  163.       while (I < N) and (Np <> nil) do
  164.         begin
  165.           Np := Next(Np);    { next object in list }
  166.           Inc(I)
  167.         end;
  168.       Specific := Np
  169.     end
  170. end;
  171. {----------------------------------------------------------------------------}
  172. { Cardinal returns the number of items (0 - 65535) in the list. After
  173.   returning, the list current item is the last item. }
  174.  
  175. function MMenu.Cardinal : word;
  176. var
  177.   Np : NodePtr;
  178.   N : word;
  179. begin
  180.   N := 0;
  181.   Np := First;               { 1st object in list }
  182.   if Np <> nil then
  183.     repeat
  184.       Inc(N);
  185.       Np := Next(Np);        { next object in list }
  186.     until Np = nil;
  187.   Cardinal := N
  188. end;
  189. {----------------------------------------------------------------------------}
  190. { Init initializes the menu object.  SelChStr defines the characters that are
  191.   selected and returned by a menu item.  NormVideo is the non-hilited menu
  192.   item background/text colors and uses the same format as Crt unit variable
  193.   TextAttr. }
  194.  
  195. constructor MMenu.Init(SelChStr : string; NormVideo : byte);
  196. begin
  197.   Clear;    {init linked list}
  198.   if LastMode = Mono then NormVid := Black shl 4 + LightGray  {mono display}
  199.     else NormVid := NormVideo;
  200.   RevVid := (NormVid shr 4) and 7 + (NormVid shl 4) and $70; {hilite colors}
  201.   GetMem(SelStr,Length(SelChStr)+1);
  202.   SelStr^ :=SelChStr
  203. end;
  204. {----------------------------------------------------------------------------}
  205. { MenuPick displays the menu and then returns the character of the menu item
  206.   selected by the cursor/enter keys or the select character.  InitCh is the
  207.   menu item hilited when MenuPick is called.  The select characters are
  208.   defined by the Init constructor.  Esc (#27) is returned if the Esc key is
  209.   pressed.  Null (#0) is returned if the list is empty or the SelChStr string
  210.   length doesn't equal the number of menu items.   }
  211.  
  212. function MMenu.MenuPick(InitCh : char) : char;
  213.  
  214. var
  215.   Choice,Ch : char;
  216.   ListLen,LastPick,CurPick,I : word;
  217.   Term : string;
  218.   {-------}
  219.   procedure HiLite(On : boolean; Num : integer) ;
  220.   var
  221.     Mp : MItemPtr;
  222.   begin
  223.     Mp := MItemPtr(Specific(Num));
  224.     GoToXY(Mp^.C,Mp^.R);
  225.     if On then
  226.       begin
  227.         TextAttr := RevVid;
  228.         Write(Mp^.PTitle^);
  229.         TextAttr := NormVid;
  230.       end
  231.     else
  232.       begin
  233.         TextAttr := NormVid;
  234.         Write(Mp^.PTitle^)
  235.       end
  236.   end;  {HiLite}
  237.   {--------}
  238. begin
  239.   ListLen := Cardinal;                           {number of items in the list}
  240.   I := Length(SelStr^);
  241.   if (I <> 0) and (I = ListLen) then
  242.     begin
  243.       CursorOn(false);
  244.       Term := SelStr^ + #13 + #27;
  245.       LastPick := Pos(InitCh,SelStr^);
  246.       if LastPick = 0 then LastPick := 1;      {make sure InitChoice is valid}
  247.       CurPick := LastPick;
  248.       for I := 1 to ListLen do                                  {display menu}
  249.         if I = CurPick then HiLite(true,I) else HiLite(false,I);
  250.       Choice := SelStr^[CurPick];                             {initial choice}
  251.       HiLite(true,CurPick);
  252.       repeat
  253.         Ch := ReadValidChar(SelStr^+#13+#27+#199+#200+#201+#203+#205+#207+
  254.                                                                   #208+#209);
  255.         LastPick := CurPick;
  256.         if Pos(Ch,SelStr^) <> 0 then                   {Ch in 1st char string}
  257.           begin
  258.             Choice := Ch;
  259.             CurPick := Pos(Ch,SelStr^)
  260.           end
  261.         else                                       {Ch not in 1st char string}
  262.           begin
  263.             case Ch of
  264.               #208,#205 : if LastPick < ListLen then CurPick := LastPick+1
  265.                             else CurPick := 1;                {Dn/Right Arrow}
  266.               #200,#203 : if LastPick > 1 then                 {Up/Left Arrow}
  267.                             CurPick := LastPick-1
  268.                           else
  269.                             CurPick := ListLen;
  270.               #199,#201 : CurPick := 1;                            {Home/PgUp}
  271.               #207,#209 : CurPick := ListLen                        {End/PgDn}
  272.             end;
  273.             Choice := SelStr^[CurPick]
  274.           end;
  275.         if LastPick <> CurPick then
  276.           begin
  277.             HiLite(false,LastPick);
  278.             HiLite(true,CurPick)
  279.           end;
  280.       until Pos(Ch,Term) <> 0;
  281.       CursorOn(true);
  282.       if Ch = #27 then MenuPick := #27   {Esc}
  283.         else MenuPick := Choice
  284.     end
  285.   else
  286.     MenuPick := #0
  287. end; {MenuPick}
  288. {----------------------------------------------------------------------------}
  289. { EraseMenu clears the menu from the display by writing spaces using the
  290.   current value of Crt gobal unit variable TextAttr.  Then the data is
  291.   deallocated from heap memory.   }
  292.  
  293. destructor MMenu.EraseMenu;
  294. var
  295.   Mp : MItemPtr;
  296. begin
  297.   Mp := MItemPtr(First);
  298.   while (Mp <> nil) do
  299.     begin
  300.       GoToXY(Mp^.C,Mp^.R);
  301.       Write(' ':Length(Mp^.PTitle^));
  302.       Mp := MItemPtr(Next(Mp))
  303.     end;
  304.   Done
  305. end;
  306. {----------------------------------------------------------------------------}
  307. { Done deallocates data from heap memory. }
  308.  
  309. destructor MMenu.Done;
  310. begin
  311.   FreeMem(SelStr,Length(SelStr^)+1);
  312.   Delete
  313. end;
  314. {----------------------------------------------------------------------------}
  315. end. {BMenu}
  316.